Shareware Grab Bag/Shareware Grab Bag.iso/011/tsr.arc/RELEASE.PAS

Pascal/Delphi Source File | 1986-05-22 | 17.3 KB | 500 lines

{**************************************************************************
*   Releases memory above the last MARK call made.                        *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   Version 1.0 2/8/86                                                    *
*     original public release.                                            *
*     (thanks to Neil Rubenking for an outline of the method used)        *
*   Version 1.1 2/11/86                                                   *
*     fixed problem with processes which deallocate their environment.    *
*   Version 1.2 2/13/86                                                   *
*     fixed another problem with processes which deallocate environment.  *
*   Version 1.3 2/15/86                                                   *
*     added support for "named" marks.                                    *
*   Version 1.4 2/23/86                                                   *
*     added support for releasing programs which use Expanded Memory.     *
*   Version 1.5 2/28/86                                                   *
*     added more bulletproof method of finding first allocation block.    *
*   Version 1.6 3/20/86                                                   *
*     restore all FF interrupts.                                          *
*     restore the termination address to the local process.               *
*     reduce number of EMS blocks to 32.                                  *
*     fix bug in number of EMS handles in EMS release step.               *
*     restore a mysterious address in the PSP which allows RELEASE of a   *
*       COMMAND shell (emulates the EXIT command).                        *
*   Version 1.7 (date not recorded)                                       *
*     add "protected marks".                                              *
*   Version 1.8 4/21/86                                                   *
*     fix problem when mark is installed as 'MARK '.                      *
*   Version 1.9 5/22/86                                                   *
*     release the environment of MARK when it is not contiguous with      *
*       the MARK itself.                                                  *
*     capture RELEASE calls from within batch files and don't release the *
*       batch file allocation block.                                      *
*     fiddle with different methods of restoring interrupt vectors in     *
*       an attempt to successfully remove DoubleDos. No success, not      *
*       implemented (yet).                                                *
*                                                                         *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}
{$C-}

program ReleaseTSR;
  {-release system memory above the last mark call}
  {-release expanded memory blocks allocated since the last mark call}

const
  Version = '1.9';
  ProtectChar = '!';          {marks whose name begins with this will be
                              released ONLY if an exact name match occurs}
  MaxBlocks = 128;            {max number of DOS allocation blocks supported}
  MaxHandles = 32;            {max number of EMS allocation blocks supported}
  EMSinterrupt = $67;         {the vector used by the expanded memory manager}

  markID = 'MARK PARAMETER BLOCK FOLLOWS'; {marking string for TSR MARK}

  {offsets into resident copy of MARK.COM for data storage}
  markOffset = $103;          {where markID is found in TSR}
  vectorOffset = $120;        {where vector table is stored}
  EMScntOffset = $520;        {where count of EMS active pages is stored}
  EMSmapOffset = $522;        {where the page map is stored}

  debug = false;              {set true for detailed output report}

type
  registers =
  record
    case Integer of
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  end;

  HandlePageRecord =
  record
    handle : Integer;
    numpages : Integer;
  end;

  PageArray = array[1..MaxHandles] of HandlePageRecord;
  PageArrayPtr = ^PageArray;

  Block =
  record                      {store info about each memory block}
    mcb : Integer;
    psp : Integer;
    releaseIt : Boolean;
  end;

  BlockType = 0..MaxBlocks;
  BlockArray = array[BlockType] of Block;
  AllStrings = string[255];
  HexString = string[4];

var
  Blocks : BlockArray;
  bottomBlock, blockNum : BlockType;
  markName : AllStrings;
  Regs : registers;
  ReturnCode, StartMCB, StoredHandles, EMShandles : Integer;
  Map, StoredMap : PageArrayPtr;
  TrappedBytes : Real;

  procedure FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    function GetStartMCB : Integer;
      {-return the first MCB segment}
    begin
      Regs.ah := $52;
      MsDos(Regs);
      GetStartMCB := MemW[Regs.es:(Regs.bx-2)];
    end {getstartmcb} ;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Integer;
                            var gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    var
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    begin

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        blockNum := Succ(blockNum);
        gotFirst := True;
        with Blocks[blockNum] do begin
          mcb := mcbSeg;
          psp := pspAdd;
        end;
      end;

    end {storetheblock} ;

  begin

    {initialize}
    StartMCB := GetStartMCB;
    mcbSeg := StartMCB;
    gotFirst := False;
    gotLast := False;
    blockNum := 0;

    {scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then mcbSeg := nextSeg else mcbSeg := Succ(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else begin
        {start block was invalid}
        WriteLn('Corrupted allocation chain or program error....');
        Halt(1);
      end;
    until gotLast;

  end {findtheblocks} ;

  function StUpcase(s : AllStrings) : AllStrings;
    {-return the uppercase string}
  var
    i : Byte;
  begin
    for i := 1 to Length(s) do s[i] := UpCase(s[i]);
    StUpcase := s;
  end {stupcase} ;

  function FindMark(idString, markName : AllStrings;
                    idOffset : Integer) : Integer;
    {-find the last memory block matching idstring at offset idoffset}
  var
    b : BlockType;
    FoundIt : Boolean;

    function MatchString(segment : Integer;
                         idString, markName : AllStrings;
                         idOffset : Integer;
                         var b : BlockType) : Boolean;
      {-return true if idstring is found at segment:idoffset}
    var
      tString : AllStrings;
      len : Byte;
      FoundIt : Boolean;

    begin
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      FoundIt := (tString = idString);
      if FoundIt then begin
        {check the mark name stored in the PSP of the mark block}
        Move(Mem[segment:$80], tString[0], 128);
        while (Length(tString) > 0) and ((tString[1] = ' ') or (tString[1] = ^I)) do
          Delete(tString, 1, 1);
        if (markName <> '') then begin
          FoundIt := (StUpcase(tString) = StUpcase(markName));
          if not(FoundIt) then
            if (Length(tString) > 0) and (tString[1] = ProtectChar) then
              {current mark is protected, stop searching}
              b := 1;
        end else if (Length(tString) > 0) and (tString[1] = ProtectChar) then begin
          {stored mark name is protected}
          FoundIt := False;
          b := 1;             {stop checking any more}
        end {else match any mark} ;
      end;
      if not(FoundIt) then b := Pred(b);
      MatchString := FoundIt;
    end {matchstring} ;

  begin
    {scan from the last block-1 down to find the last MARK TSR}
    b := Pred(blockNum);
    repeat
      FoundIt := MatchString(Blocks[b].psp, idString, markName, idOffset, b);
    until (b < 1) or FoundIt;
    if not(FoundIt) then begin
      WriteLn('No matching marker found, or protected marker encountered.');
      Halt(1);
    end;
    FindMark := b;
  end {findmark} ;

  function Hex(i : Integer) : HexString;
    {-return hex representation of integer}
  const
    hc : array[0..15] of Char = '0123456789ABCDEF';
  var
    l, h : Byte;
  begin
    l := Lo(i); h := Hi(i);
    Hex := hc[h shr 4]+hc[h and $F]+hc[l shr 4]+hc[l and $F];
  end {hex} ;

  procedure CopyVectors(bottomBlock : BlockType; vectorOffset : Integer);
    {-put interrupt vectors back into table}
  begin
    {interrupts off}
    inline($FA);
    {restore the main interrupt vector table}
    move(Mem[Blocks[bottomBlock].psp:vectorOffset], Mem[0:0], 512);
    {move the old termination/break/error addresses into this program}
    Move(Mem[0:$88], Mem[CSeg:$0A], 6);
    {restore a mysterious address used by the DOS EXIT command to remove a shell}
    move(Mem[CSeg:$0C], Mem[CSeg:$16], 1);
    {interrupts on}
    inline($FB);
  end {copyvectors} ;

  procedure MarkBlocks(bottomBlock : BlockType);
    {-mark those blocks to be released}
  var
    b, t : BlockType;
    commandPsp, markPsp : Integer;

    function cardinal(i : Integer) : Real;
      {-return "unsigned integer" in range 0..65535}
    var
      r : Real;
    begin
      r := i;
      if r < 0.0 then r := r+65536.0;
      cardinal := r;
    end {cardinal} ;

  begin

    commandPsp := Blocks[2].psp;
    markPsp := Blocks[bottomBlock].psp;

    for b := 1 to blockNum do with Blocks[b] do begin

      if (b < bottomBlock) then
        {release the environment of the mark}
        releaseIt := (psp = markPsp)
      else begin
        {release all but RELEASE itself and any blocks owned by COMMAND.COM}
        releaseIt := (psp <> CSeg) and (psp <> commandPsp);

        if (psp = commandPsp) then begin
          {warn about the trapping effect of batch files}
          WriteLn('Memory space for TSRs installed prior to batch file');
          WriteLn('will not be released until batch file completes.');
          WriteLn;
          ReturnCode := 1;
          {compute number of bytes temporarily trapped}
          TrappedBytes := 0.0;
          for t := 1 to b do if Blocks[t].releaseIt then
            TrappedBytes := TrappedBytes+16.0*cardinal(MemW[Blocks[t].mcb:3]);
        end;
      end;
    end;

    if debug then
      for b := 1 to blockNum do with Blocks[b] do
        WriteLn(b:3, ' ', Hex(mcb), ' ', Hex(psp), ' ', releaseIt);

  end {markblocks} ;

  procedure ReleaseMem;
    {release DOS memory marked for release}
  var
    b : BlockType;
  begin
    with Regs do
      for b := 1 to blockNum do with Blocks[b] do
        if releaseIt then begin
          ah := $49;
          {the block is always 1 paragraph above the MCB}
          es := Succ(mcb);
          MsDos(Regs);
          if Odd(flags) then begin
            WriteLn('Could not release block at segment ', Hex(es));
            WriteLn('Memory is now a mess... Please reboot');
            Halt(1);
          end;
        end;
  end {releasemem} ;

  function EMSpresent : Boolean;
    {-return true if EMS memory manager is present}
  var
    f : file;
  begin
    {"file handle" defined by the expanded memory manager at installation}
    Assign(f, 'EMMXXXX0');
    {$I-} Reset(f) {$I+} ;
    EMSpresent := (IOResult = 0);
    Close(f);
  end {EMSpresent} ;

  function EMShandlesActive : Integer;
    {-return the number of active EMS handles}
  begin
    Regs.ah := $4B;
    Intr(EMSinterrupt, Regs);
    if Regs.ah <> 0 then begin
      WriteLn('EMS device not responding');
      EMShandlesActive := 0;
      Exit;
    end;
    EMShandlesActive := Regs.bx;
  end {EMShandlesActive} ;

  function GetHandles(bottomBlock : BlockType; EMScntOffset : Integer) : Integer;
    {-return the number of handles stored by mark}
  var
    gh : Integer;
  begin
    Move(Mem[Blocks[bottomBlock].psp:EMScntOffset], gh, 2);
    GetHandles := gh;
  end {gethandles} ;

  procedure EMSpageMap(var PageMap : PageArray);
    {-return an array of the allocated memory blocks}
  begin
    Regs.ah := $4D;
    Regs.es := Seg(PageMap);
    Regs.di := Ofs(PageMap);
    Regs.bx := 0;
    Intr(EMSinterrupt, Regs);
    if Regs.ah <> 0 then
      WriteLn('EMS device not responding');
  end {EMSpageMap} ;

  procedure ReleaseEMSblocks(var oldmap, newmap : PageArray);
    {-release those EMS blocks allocated since MARK was installed}
  var
    o, n, nhandle : Integer;

    procedure EMSdeallocate(EMShandle : Integer);
      {-release the allocated expanded memory}
    begin
      Regs.ah := $45;
      Regs.dx := EMShandle;
      Intr(EMSinterrupt, Regs);
      if Regs.ah <> 0 then begin
        WriteLn('Program error or EMS device not responding');
        WriteLn('EMS memory is now a mess... Please reboot');
        Halt(1);
      end;
    end;                      {EMSdeallocate}

  begin
    for n := 1 to EMShandles do begin
      {scan all current handles}
      nhandle := newmap[n].handle;
      if StoredHandles > 0 then begin
        {see if current handle matches one stored by MARK}
        o := 1;
        while (oldmap[o].handle <> nhandle) and (o <= StoredHandles) do
          o := Succ(o);
        {if not, deallocate the current handle}
        if (o > StoredHandles) then
          EMSdeallocate(nhandle);
      end else
        {no handles stored by MARK, deallocate all current handles}
        EMSdeallocate(nhandle);
    end;
  end {releaseEMSblocks} ;

begin

  WriteLn;
  ReturnCode := 0;

  {see if a particular mark is named}
  if ParamCount > 0 then
    markName := ParamStr(1)
  else
    markName := '';

  if debug then
    writeln('finding all memory blocks');

  {get all allocated memory blocks in normal memory}
  FindTheBlocks;

  if debug then
    writeln('finding the marked block');

  {find the last one marked with the MARK idstring, and MarkName if specified}
  bottomBlock := FindMark(markID, markName, markOffset);

  if debug then
    writeln('marking blocks to release');

  {mark those blocks to be released}
  MarkBlocks(bottomBlock);

  if debug then
    writeln('copying old interrupt vector table');

  {copy the vector table from the MARK resident}
  CopyVectors(bottomBlock, vectorOffset);

  if debug then
    writeln('releasing marked memory blocks');

  {release normal memory marked for release}
  ReleaseMem;

  if debug then
    writeln('dealing with expanded memory');

  {see if expanded memory card is installed}
  if EMSpresent then begin
    {see how many EMS handles are currently active}
    EMShandles := EMShandlesActive;
    if EMShandles > MaxHandles then
      WriteLn('EMS process count exceeds capacity of RELEASE')
    else if EMShandles <> 0 then begin
      {see how many handles were active when MARK was installed}
      StoredHandles := GetHandles(bottomBlock, EMScntOffset);
      {get the existing EMS page map}
      GetMem(Map, 4*EMShandles);
      EMSpageMap(Map^);
      {get the stored page map}
      StoredMap := Ptr(Blocks[bottomBlock].psp, EMSmapOffset);
      {compare the two maps and deallocate those not in the stored map}
      ReleaseEMSblocks(StoredMap^, Map^);
    end;
  end;

  {DOS will release this program's memory when it exits}
  {write success message}
  Write('RELEASE ', Version, ' - Memory released above last MARK ');
  if markName <> '' then
    WriteLn('(', StUpcase(markName), ')')
  else
    WriteLn;

  if ReturnCode <> 0 then
    WriteLn(TrappedBytes:0:0, ' bytes temporarily trapped until batch file completes');

  Halt(ReturnCode);
end.